home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
TSR
/
STAY50
/
DEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-11-28
|
20KB
|
498 lines
{$I direct.inc}
{──────────────────────────────────────────────────────────────────────}
{ Turbo Pascal Stay Resident Shell Demonstation }
{ Copyright (C) 1988 Lane Ferris }
{──────────────────────────────────────────────────────────────────────}
{ Send Suggestions and Bug reports to COMPUSERVE ID: 70357,2716 }
{ or write: 4268 26th St. SanFrancisco, Ca 94131 }
{──────────────────────────────────────────────────────────────────────}
uses
crt,dos,
macros, { assorted inlines }
SR50, { stayres kernel }
SR50subs, { stayres subs }
SRmsgu , { mailbox unit }
FListu ; { file list unit }
const
AltD : word = $2000 ; { AltD int 16 keycode }
AltL : word = $2600 ; { AltL int 16 keycode }
var
Attr : byte ;
{────────────────────────────────────────────────────────────────}
{ Clock }
{────────────────────────────────────────────────────────────────}
{ Displays digital clock in upper right of screen }
{────────────────────────────────────────────────────────────────}
{$F+}Procedure Clock ; {$F-}
var
SystemTimer : longint absolute $40:$6c ;
Hours : longint ;
minutes,
seconds : longint ;
ticks : longint ;
Hoursstr : string[2] ;
Minutesstr : string[2] ;
secondsstr : string[2] ;
ampm : string[2] ;
ClockStr : string[11] ;
SaveWindow : array[1..4] of byte ;
SaveCurPos : word ;
BiosCurPos : word absolute $40:$50 ; { BIOS cursor position page 1 }
BEGIN
While true do begin { do forever }
ticks := SystemTimer ;
Hours := ticks div 65543 ; { 65543 ticks per hour }
dec(ticks,Hours*65543) ;
minutes := ticks div 1092 ; { 1092 ticks per minute }
dec(ticks,minutes*1092) ;
seconds := ticks div 18 ; { 18.2 ticks per second }
(** { account for .2 tick error }
seconds := seconds - (seconds div 20) ; { as 1 tick in 20 err }
**)
if seconds >59 then seconds := 59 ;
if Hours > 12 then begin
dec(Hours,12) ;
ampm := 'pm' ;
end
else ampm := 'am' ;
str(Hours :2,hoursstr ) ;
str(Minutes:2,minutesstr ) ;
str(seconds:2,secondsstr ) ;
{ force leading zeros }
Hoursstr[1] := char(ord(hoursstr[1]) or ord('0')) ;
Minutesstr[1] := char(ord(Minutesstr[1]) or ord('0')) ;
Secondsstr[1] := char(ord(Secondsstr[1]) or ord('0')) ;
ClockStr := Hoursstr+':'+Minutesstr+':'+secondsstr+ampm ;
resource(reserve,_crt) ;
move(Windmin,SaveWindow,4) ;
SaveCurPos := BiosCurPos ;
window(68,1,79,2) ; { a window resets cursor posn etc }
write( ClockStr) ;
move(SaveWindow,Windmin,4) ;
BiosCurPos := SaveCurPos ;
resource(rlse,_crt) ;
Yield ; { give up cpu control }
end {while true } ;
END; {Clock}
{───────────────────────────────────────────────────────────────}
{ ShowDir }
{───────────────────────────────────────────────────────────────}
{ Yet another directory display routine }
{───────────────────────────────────────────────────────────────}
const
maxentries = 78 ; {≈1024 bytes}
var
Filenames : array[1..maxentries] of string[13] ;
OldWindowPtr : pointer ; { pointer to old window on heap }
const
DirContents : pointer = nil ; { process window contents to restore }
{───────────────────────────────────────────────────────────────}
{ DirPop }
{───────────────────────────────────────────────────────────────}
{ popup/dn maintenance routine called from SR50 }
{ each time the hotkey is activated from the keyboard }
{───────────────────────────────────────────────────────────────}
{$F+} Procedure DirPop(popupdn:boolean) ; {$F-}
Begin
resource(reserve,_crt) ;
case popupdn of
True : Begin { This is a popup }
SaveWindow(1,1,68,20,OldWindowPtr) ; { save forgound window }
BorderWindow(1,1,68,20,border) ; { make window with border }
if DirContents <> nil then { restore contents if any }
RestoreWindow(2,2,67,19,DirContents) ;
end {popup} ;
false: Begin { this is a popdown}
SaveWindow(2,2,67,19,DirContents) ; { save window contents }
RestoreWindow(1,1,68,20,OldWindowPtr) ; { restore foreground }
end {popdown}
end {case};;
resource(rlse,_crt) ;
End {DirPop} ;
{───────────────────────────────────────────────────────────────}
{ Sort em }
{───────────────────────────────────────────────────────────────}
{ Insertion sort filenames into alpa order }
{───────────────────────────────────────────────────────────────}
Procedure Sortem(entries : integer ) ;
var
i, j, lowest, highest, center : integer ;
tempstr : string[13] ;
begin
for i := 2 to entries do begin
tempstr := Filenames[i] ;
lowest := 1 ;
highest := i - 1 ;
while lowest <= highest do begin
center := (lowest + highest) div 2 ;
if tempstr < filenames[center] then
highest := center - 1
else lowest := center +1 ;
end {while lowest..} ;
for j := i - 1 downto lowest do
filenames[j+1] := filenames[j] ;
filenames[lowest] := tempstr ;
end {for i..} ;
end {Sortem} ;
{───────────────────────────────────────────────────────────────}
{ Show em }
{───────────────────────────────────────────────────────────────}
{ display partial sorted directory entries on video }
{───────────────────────────────────────────────────────────────}
Procedure Showem(entries : integer ) ;
var
i, j : integer ;
begin
clrscr ;
j := 0 ;
for i := 1 to entries do begin
Resource(reserve,_CRT) ;
write(filenames[i]) ;
Resource( rlse,_CRT) ;
inc(j) ;
if j = 5 then begin
Resource(reserve,_CRT) ;
writeln ;
Resource(rlse,_CRT) ;
j := 0 ;
end{if j}
end {for i} ;
end{showem} ;
{───────────────────────────────────────────────────────────────}
{ ShowDir (main procedure) }
{───────────────────────────────────────────────────────────────}
Procedure ShowDir ;
const
blanks : string[13] = ' ' ;
var
FilePath : string ;
FileAttr : byte ;
FileSearchRec : SearchRec ;
i : integer ;
ch : char ;
begin {ShowDir}
FilePath := '*.*' ;
FileAttr := AnyFile ;
i := 1 ;
FindFirst(FilePath,FileAttr,FileSearchRec) ;
while DosError = 0 do begin
With FileSearchRec do begin
blanks[0] := char(13-length(name)) ;
Filenames[i] := Name+blanks ;
inc(i) ;
if i = maxentries+1 then begin
sortem(i-1) ;
showem(i-1) ;
Resource(reserve,_CRT) ;
writeln;write('Count was: ',i-1) ;
Resource(rlse,_CRT) ;
while not keypressed do Yield ;
ch := readkey ; { eat the key }
i := 1 ; { restart the array }
end {if i..} ;
end {with file..} ;
FindNext( FileSearchRec ) ;
end{while DosError..} ;
sortem(i-1) ;
showem(i-1) ;
Resource(reserve,_CRT) ;
writeln;writeln('Count was: ',i-1) ;
Resource(rlse,_CRT) ;
while not keypressed do yield ;
ch := readkey ;
End {ShowDir} ;
{────────────────────────────────────────────────────────────────}
{ DirTask }
{────────────────────────────────────────────────────────────────}
{ Hotkey task in infinite loop with Yield to SR50 at bottom }
{────────────────────────────────────────────────────────────────}
Procedure DirTask ;
begin
While true do begin
ShowDir ; { Display the Directory }
Yield ; { tell SR50 its finished }
end {while true..} ;
end {DirTask} ;
{────────────────────────────────────────────────────────────────}
{ ListFile }
{────────────────────────────────────────────────────────────────}
{ If you're one who believes that Dinasours died of their own }
{ stupditiy.. you'll love this. }
{────────────────────────────────────────────────────────────────}
{ This is an exercise in mailbox maintenance. It sends commands }
{ to a mailbox, and receives the results. Message passing is fun }
{ .. but, ever so slow.. Dinasaurs dont care . }
{────────────────────────────────────────────────────────────────}
Const
ListContents : pointer = nil ; { contents of window }
{───────────────────────────────────────────────────────────────}
{ ListPop }
{───────────────────────────────────────────────────────────────}
{ popup/down maintenance routine called from SR50 }
{───────────────────────────────────────────────────────────────}
{$F+} Procedure ListPop(popupdn:boolean) ; {$F-}
Begin
resource(reserve,_crt) ;
case popupdn of
True : Begin { This is a popup }
SaveWindow(4,4,68,21,OldWindowPtr) ; { save forgound window }
BorderWindow(4,4,68,21,border) ; { make window with border }
if ListContents <> nil then { restore contents if any }
RestoreWindow(5,5,67,20,ListContents) ;
end {popup} ;
false: Begin { this is a popdown}
SaveWindow(5,5,67,20,ListContents) ; { save window contents }
RestoreWindow(4,4,68,21,OldWindowPtr) ; { restore foreground }
end {popdown}
end {case};;
resource(rlse,_crt) ;
End {ListPop} ;
{───────────────────────────────────────────────────────────────}
{ ListTask }
{───────────────────────────────────────────────────────────────}
{ Alt-L popup Showing lines of a file in window }
{───────────────────────────────────────────────────────────────}
Procedure ListTask ;
const
esc = 27 ;
pgup = 73 + 128 ;
pgdn = 81 + 128 ;
uparr = 72 + 128 ;
dnarr = 80 + 128 ;
ctlpgup = 132 + 128 ;
ctlpgdn = 118 + 128 ;
ctlhome = 119 + 128 ;
ctlend = 117 + 128 ;
pagesize = 10 ;
var
i : integer ;
key : integer ; { keyboard input + 128 }
LineNr : integer ; { File line number }
LastLineNr : integer ; { Last line in file }
Nrtoshow : integer ; { Num lines to show }
result : integer ; { perverbial round can }
StrPtr : pointer ; { utility pointer }
message : string ; { utility string }
done : boolean ; { utility boolean }
textwidth : byte ; { max text to write }
begin {main}
MakeMailbox('ListMail') ; { Make a listing mailbox }
While True do Begin { repeat forever }
textwidth := lo(windmax) - lo(windmin) - 6 ;
Clrscr ;
REPEAT {until done }
resource(reserve,_CRT) ;
write('Enter Filename to List:');
resource(rlse,_CRT) ;
Readln(Message) ;
Message := 'Open '+Message ; { create Open file command }
Send('ListMail',@Message) ; { Send command to mailbox }
Receive('ListMail',strptr) ; { wait for message reply }
if integer(strptr^) = 0
then done := true
else done := false ;
UNTIL done = true ;
LineNr := 1 ;
LastLineNr := maxint ;
NrtoShow := pagesize ;
resource(reserve,_CRT) ;
clrscr ;
gotoxy((lo(windmax)-lo(windmin))shr 1-7,
(hi(windmax)-hi(windmin))shr 1) ;
writeln( '<pgup><pgdn><'#24#25'>') ;
gotoxy(1,1) ;
resource(rlse,_CRT) ;
REPEAT
key := byte(readkey) ;
if key = 0 then key := 128 + byte(readkey) ;
case key of
uparr : begin
dec(LineNr,1) ;
Nrtoshow := 1 ;
end ;
dnarr : begin
inc(LineNr) ;
Nrtoshow := 1 ;
end ;
pgup : begin
dec(LineNr,pagesize) ;
Nrtoshow := pagesize ;
end ;
pgdn : begin
inc(LineNr,pagesize) ;
NrtoShow := pagesize ;
end ;
ctlPgup,
ctlHome : begin
LineNr := 1 ;
Nrtoshow := 1 ;
end ;
ctlpgdn,
ctlEnd : begin
LineNr := maxint ;
Nrtoshow := 1 ;
end ;
esc : ;
else key := 0 ;
end {case} ;
if key <> 0 then begin
if LineNr > LastLineNr then LineNr := LastLineNr - 1;
if LineNr < 1 then LineNr := 1 ;
if LineNr-1+Nrtoshow > LastLineNr then
Nrtoshow := LastLineNr-LineNr+1 ;
for i := LineNr to LineNr-1+Nrtoshow do
begin
str(i,Message) ;
Message := 'Read '+Message ;
Strptr := @Message ;
Send('ListMail',Strptr) ; { Send readfile to mailbox }
Receive('ListMail',strptr) ; { wait for message reply }
{ Strptr := FLgetNr(i) ; }
if Strptr <> nil then begin
if string(Strptr^)[1] = #26 then
val(copy(string(Strptr^),2,5),LastLineNr,result) ;
if byte(Strptr^) > textwidth { truncate string & write }
then byte(Strptr^) := textwidth ;
if string(strptr^)[length(string(strptr^))-1] = ^M
then dec(string(strptr^)[0],2) ;
resource(reserve,_crt) ;
writeln(i:3,string(Strptr^)) ;
resource(rlse,_crt) ;
end ;
if (Strptr = nil) then { an error has occured }
LastLineNr := 1 ;
end {for..} ;
end {if key..} ;
UNTIL key = esc ;
{ FLclose('test.dat') ;}
Message := 'Close sr50.pas' ;
Send('ListMail',@Message) ; { Send open file to mailbox }
Receive('ListMail',strptr) ; { wait for message reply }
End {while True} ;
End {ListTask} ;
{────────────────────────────────────────────────────────────────}
{ List Send/Receive task }
{────────────────────────────────────────────────────────────────}
{ Execute commands from 'ListMail' box and send back results }
{────────────────────────────────────────────────────────────────}
Procedure ListCmds ;
var
Strptr : pointer ;
result : integer ;
lineNr : word ;
Cmdstr : string[5] ;
Begin
While true do begin {forever}
REPEAT
{ loop until Mailbox is created and a message is waiting }
Receive('ListMail',Strptr) ;
if Strptr = nil then yield ;
UNTIL Strptr <> nil ;
Cmdstr := copy(string(Strptr^),1,pos(' ',string(Strptr^))-1) ;
Caps(Cmdstr) ;
If Cmdstr = 'OPEN' then begin
result := FLopen(copy(string(Strptr^),6,sizeof(Filenamestr)-1)) ;
Send('ListMail',@result) ;
end {if..open} ;
If Cmdstr = 'CLOSE' then begin
FLclose(copy(string(Strptr^),7,sizeof(Filenamestr)-1)) ;
result := 0 ;
Send('ListMail',@result) ;
end {if..close} ;
If CmdStr = 'READ' then begin
{$R-} val(copy(string(Strptr^),6,5),lineNr,result) ; {$R+}
if result <>0 then Strptr := nil
else FLgetNr(lineNr,string(Strptr^)) ; { get data string or }
Send('ListMail',Strptr) ; { nil if end of file }
end {if..read} ;
end {while..forever} ;
End {ListSR} ;
{────────────────────────────────────────────────────────────────}
{ Main }
{────────────────────────────────────────────────────────────────}
begin {main}
{ Debug should be false to allow SR to go resident }
{ else it runs as a normal (if that's the word) task }
SR50.Debug := false ; { turn off/on debugging }
if paramstr(1) = 'debug' then SR50.Debug := true ;
writeln ;
writeln(RUTidBlk.RUTidStr, ' is active' ) ;
writeln;
writeln( '<AltD> toggles a directory list' ) ;
writeln( '<AltL> toggles a program list' ) ;
writeln;
writeln('"DEMO quit" will terminate the demonstation') ;
writeln;
writeln( ' copyright (c) 1988 Lane Ferris ' ) ;
writeln( ' The Hunters'' Helper' ) ;
writeln ;
Attr := textattr or $08 ; ; { bright clock color }
Attach(@Clock,TimerType,18,NIL,'CLOCK') ; { Add Clock as a task }
Attach(@DirTask,KeyType,AltD, { Add ShowDir task }
@DirPop,'DIRPOP') ;
Attach(@ListTask,KeyType,AltL, { Add List Display task }
@ListPop,'LISTPOP') ;
Attach(@ListCmds,TimerType,1, { Add File Read task }
NIL,'LISTCMDS') ;
StartTSR ; { jump to TSR code }
{ never to return here }
end. {main}
(**)FREEZE;NMI;(**)